home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / symbol.d < prev    next >
Encoding:
Text File  |  1994-05-07  |  12.9 KB  |  659 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19. */
  20.  
  21. /*
  22.     symbol.d
  23. */
  24.  
  25. #include "include.h"
  26.  
  27. object siSpname;
  28.  
  29. set_up_string_register(s)
  30. char *s;
  31. {
  32.     string_register->st.st_fillp =
  33.     string_register->st.st_dim = strlen(s);
  34.     string_register->st.st_self = s;
  35. }
  36.  
  37. object
  38. make_symbol(st)
  39. object st;
  40. {
  41.     object x;
  42.     int i;
  43.  
  44.     x = alloc_object(t_symbol);
  45.     x->s.s_dbind = OBJNULL;
  46.     x->s.s_sfdef = NOT_SPECIAL;
  47.     x->s.s_fillp = st->st.st_fillp;
  48.     x->s.s_self = NULL;
  49.     x->s.s_gfdef = OBJNULL;
  50.     x->s.s_plist = Cnil;
  51.     x->s.s_hpack = Cnil;
  52.     x->s.s_stype = (short)stp_ordinary;
  53.     x->s.s_mflag = FALSE;
  54.     vs_push(x);
  55.     if (initflag==0 && st->st.st_self < heap_end)
  56.         x->s.s_self = st->st.st_self;        
  57.     else {
  58.         x->s.s_self = alloc_relblock(x->s.s_fillp);
  59.         for (i = 0;  i < x->s.s_fillp;  i++)
  60.             x->s.s_self[i] = st->st.st_self[i];
  61.     }
  62.     return(vs_pop);
  63. }
  64.  
  65. /*
  66.     Make_ordinary(s) makes an ordinary symbol from C string s
  67.     and interns it in lisp package as an external symbol.
  68. */
  69.  
  70. #define P_EXTERNAL(x,j) ((x)->p.p_external[(j) % (x)->p.p_external_size])
  71.  
  72.  
  73. object
  74. make_ordinary(s)
  75. char *s;
  76. {
  77.     int i, j;
  78.     object x, l, *ep;
  79.     vs_mark;
  80.  
  81.     set_up_string_register(s);
  82.     j = pack_hash(string_register);
  83.     ep = &P_EXTERNAL(lisp_package,j);
  84.     for (l = *ep;  type_of(l) == t_cons;  l = l->c.c_cdr)
  85.         if (string_eq(l->c.c_car, string_register))
  86.             return(l->c.c_car);
  87.     x = make_symbol(string_register);
  88.     vs_push(x);
  89.     x->s.s_hpack = lisp_package;
  90.     *ep = make_cons(x, *ep);
  91.     lisp_package->p.p_external_fp ++;
  92.     vs_reset;
  93.     return(x);
  94. }
  95.  
  96. /*
  97.     Make_special(s, v) makes a special variable from C string s
  98.     with initial value v in lisp package.
  99. */
  100. object
  101. make_special(s, v)
  102. char *s;
  103. object v;
  104. {
  105.     object x;
  106.  
  107.     x = make_ordinary(s);
  108.     x->s.s_stype = (short)stp_special;
  109.     x->s.s_dbind = v;
  110.     return(x);
  111. }
  112.  
  113. /*
  114.     Make_constant(s, v) makes a constant from C string s
  115.     with constant value v in lisp package.
  116. */
  117. object
  118. make_constant(s, v)
  119. char *s;
  120. object v;
  121. {
  122.     object x;
  123.  
  124.     x = make_ordinary(s);
  125.     x->s.s_stype = (short)stp_constant;
  126.     x->s.s_dbind = v;
  127.     return(x);
  128. }
  129.  
  130. /*
  131.     Make_si_ordinary(s) makes an ordinary symbol from C string s
  132.     and interns it in system package as an external symbol.
  133.     It assumes that the (only) package used by system is lisp.
  134. */
  135.  
  136.  
  137.  
  138. object
  139. make_si_ordinary(s)
  140. char *s;
  141. {
  142.     int i, j;
  143.     object x, l, *ep;
  144.     vs_mark;
  145.  
  146.     set_up_string_register(s);
  147.     j = pack_hash(string_register);
  148.     ep = & P_EXTERNAL(system_package,j);
  149.     for (l = *ep;  type_of(l) == t_cons;  l = l->c.c_cdr)
  150.         if (string_eq(l->c.c_car, string_register))
  151.             return(l->c.c_car);
  152.     for (l =  P_EXTERNAL(lisp_package,j);
  153.          type_of(l) == t_cons;
  154.          l = l->c.c_cdr)
  155.         if (string_eq(l->c.c_car, string_register))
  156.             error("name conflict --- can't make_si_ordinary");
  157.     x = make_symbol(string_register);
  158.     vs_push(x);
  159.     x->s.s_hpack = system_package;
  160.     system_package->p.p_external_fp ++;
  161.     *ep = make_cons(x, *ep);
  162.     vs_reset;
  163.     return(x);
  164. }
  165.  
  166. /*
  167.     Make_si_special(s, v) makes a special variable from C string s
  168.     with initial value v in system package.
  169. */
  170. object
  171. make_si_special(s, v)
  172. char *s;
  173. object v;
  174. {
  175.     object x;
  176.  
  177.     x = make_si_ordinary(s);
  178.     x->s.s_stype = (short)stp_special;
  179.     x->s.s_dbind = v;
  180.     return(x);
  181. }
  182.  
  183. /*
  184.     Make_si_constant(s, v) makes a constant from C string s
  185.     with constant value v in system package.
  186. */
  187. object
  188. make_si_constant(s, v)
  189. char *s;
  190. object v;
  191. {
  192.     object x;
  193.  
  194.     x = make_si_ordinary(s);
  195.     x->s.s_stype = (short)stp_constant;
  196.     x->s.s_dbind = v;
  197.     return(x);
  198. }
  199.  
  200. /*
  201.     Make_keyword(s) makes a keyword from C string s.
  202. */
  203. object
  204. make_keyword(s)
  205. char *s;
  206. {
  207.     int i, j;
  208.     object x, l, *ep;
  209.     vs_mark;
  210.  
  211.     set_up_string_register(s);
  212.     j = pack_hash(string_register);
  213.     ep = &P_EXTERNAL(keyword_package,j);
  214.     for (l = *ep;  type_of(l) == t_cons;  l = l->c.c_cdr)
  215.         if (string_eq(l->c.c_car, string_register))
  216.             return(l->c.c_car);
  217.     x = make_symbol(string_register);
  218.     vs_push(x);
  219.     x->s.s_hpack = keyword_package;
  220.     x->s.s_stype = (short)stp_constant;
  221.     x->s.s_dbind = x;
  222.     *ep = make_cons(x, *ep);
  223.     keyword_package->p.p_external_fp ++;
  224.     vs_reset;
  225.     return(x);
  226. }
  227.  
  228. object
  229. symbol_value(s)
  230. object s;
  231. {
  232. /*
  233.     if (type_of(s) != t_symbol)
  234.         FEinvalid_variable("~S is not a symbol.", s);
  235. */
  236.     if (s->s.s_dbind == OBJNULL)
  237.         FEunbound_variable(s);
  238.     return(s->s.s_dbind);
  239. }
  240.  
  241. object
  242. getf(place, indicator, deflt)
  243. object place, indicator, deflt;
  244. {
  245.     object l;
  246. #define cendp(obj) ((type_of(obj)!=t_cons))
  247.     for (l = place;  !cendp(l);  l = l->c.c_cdr->c.c_cdr) {
  248.         if (cendp(l->c.c_cdr))
  249.             break;
  250.         if (l->c.c_car == indicator)
  251.             return(l->c.c_cdr->c.c_car);
  252.     }
  253.     if(l==Cnil) return deflt;
  254.     FEerror("Bad plist ~a",1,place);    
  255. }
  256.  
  257. object
  258. get(s, p, d)
  259. object s, p;
  260. {
  261.     if (type_of(s) != t_symbol)
  262.         not_a_symbol(s);
  263.     return(getf(s->s.s_plist, p, d));
  264. }
  265.  
  266. /*
  267.     Putf(p, v, i) puts value v for property i to property list p
  268.     and returns the resulting property list.
  269. */
  270. object
  271. putf(p, v, i)
  272. object p, v, i;
  273. {
  274.     object l, l0 = p;
  275.     vs_mark;
  276.  
  277.     for (l = p;  !cendp(l);  l = l->c.c_cdr->c.c_cdr) {
  278.         if (cendp(l->c.c_cdr))
  279.             break;
  280.         if (l->c.c_car == i) {
  281.             l->c.c_cdr->c.c_car = v;
  282.             return(p);
  283.         }
  284.     }
  285.         if(l!=Cnil) FEerror("Bad plist ~a",1,p);
  286.     l = make_cons(v, p);
  287.     vs_push(l);
  288.     l = make_cons(i, l);
  289.     vs_reset;
  290.     return(l);
  291. }
  292.  
  293. object
  294. putprop(s, v, p)
  295. object s, v, p;
  296. {
  297.     if (type_of(s) != t_symbol)
  298.         not_a_symbol(s);
  299.     s->s.s_plist = putf(s->s.s_plist, v, p);
  300.     return(v);
  301. }
  302.  
  303.  
  304. /* done in the right order for efficient setf.. */
  305. object
  306. sputprop(s, p, v)
  307. object s, v, p;
  308. {
  309.     if (type_of(s) != t_symbol)
  310.         not_a_symbol(s);
  311.     s->s.s_plist = putf(s->s.s_plist, v, p);
  312.     return(v);
  313. }
  314.  
  315.  
  316. /*
  317.     Remf(p, i) removes property i
  318.     from the property list pointed by p,
  319.     which is a pointer to an object.
  320.     The returned value of remf(p, i) is:
  321.  
  322.         TRUE    if the property existed
  323.         FALSE    otherwise.
  324. */
  325. bool
  326. remf(p, i)
  327. object *p, i;
  328. {
  329.     object l0 = *p;
  330.  
  331.     for(;  !endp(*p);  p = &(*p)->c.c_cdr->c.c_cdr) {
  332.         if (endp((*p)->c.c_cdr))
  333.             odd_plist(l0);
  334.         if ((*p)->c.c_car == i) {
  335.             *p = (*p)->c.c_cdr->c.c_cdr;
  336.             return(TRUE);
  337.         }
  338.     }
  339.     return(FALSE);
  340. }
  341.  
  342. object
  343. remprop(s, p)
  344. object s, p;
  345. {
  346.     if (type_of(s) != t_symbol)
  347.         not_a_symbol(s);
  348.     if (remf(&s->s.s_plist, p))
  349.         return(Ct);
  350.     else
  351.         return(Cnil);
  352. }
  353.  
  354. bool
  355. keywordp(s)
  356. object s;
  357. {
  358.     return(type_of(s) == t_symbol && s->s.s_hpack == keyword_package);
  359. /*
  360.     if (type_of(s) != t_symbol) {
  361.         vs_push(s);
  362.         check_type_symbol(&vs_head);
  363.         vs_pop;
  364.     }
  365.     if (s->s.s_hpack == OBJNULL)
  366.         return(FALSE);
  367.     return(s->s.s_hpack == keyword_package);
  368. */
  369. }
  370.  
  371. @(defun get (sym indicator &optional deflt)
  372. @
  373.     check_type_symbol(&sym);
  374.     @(return `getf(sym->s.s_plist, indicator, deflt)`)
  375. @)
  376.  
  377. Lremprop()
  378. {
  379.     check_arg(2);
  380.  
  381.     check_type_symbol(&vs_base[0]);
  382.     if (remf(&vs_base[0]->s.s_plist, vs_base[1]))
  383.         vs_base[0] = Ct;
  384.     else
  385.         vs_base[0] = Cnil;
  386.     vs_pop;
  387. }
  388.  
  389. Lsymbol_plist()
  390. {
  391.     check_arg(1);
  392.  
  393.     check_type_symbol(&vs_base[0]);
  394.     vs_base[0] = vs_base[0]->s.s_plist;
  395. }
  396.  
  397. @(defun getf (place indicator &optional deflt)
  398. @
  399.     @(return `getf(place, indicator, deflt)`)
  400. @)
  401.  
  402. @(defun get_properties (place indicator_list)
  403.     object l, m;
  404. @
  405.     for (l = place;  !endp(l);  l = l->c.c_cdr->c.c_cdr) {
  406.         if (endp(l->c.c_cdr))
  407.             odd_plist(place);
  408.         for (m = indicator_list;  !endp(m);  m = m->c.c_cdr)
  409.             if (l->c.c_car == m->c.c_car)
  410.                 @(return `l->c.c_car`
  411.                      `l->c.c_cdr->c.c_car`
  412.                      l)
  413.     }
  414.     @(return Cnil Cnil Cnil)
  415. @)
  416.  
  417.  
  418. object
  419. symbol_name(x)
  420. object x;
  421. {object y;
  422.  if (type_of(x)!=t_symbol) FEerror("Takes a symbol ~a",1,x);
  423.   for (y=x->s.s_plist; type_of(y)==t_cons ; y=y->c.c_cdr->c.c_cdr)
  424.    {if(y->c.c_car==siSpname) return(y->c.c_cdr->c.c_car);}
  425.     y = alloc_simple_string(x->s.s_fillp);
  426.     vs_push(y);
  427.    if (x->s.s_self < heap_end)
  428.         y->st.st_self = x->s.s_self;
  429.     else {int i;
  430.         y->st.st_self = alloc_relblock(x->s.s_fillp);
  431.         for (i = 0;  i < x->s.s_fillp;  i++)
  432.             y->st.st_self[i] = x->s.s_self[i];
  433.     }
  434.    x->s.s_plist = putf(x->s.s_plist, y, siSpname);
  435.     vs_pop;
  436.     return(y);
  437. }
  438.  
  439. Lsymbol_name()
  440. {
  441.     check_arg(1);
  442.         vs_base[0]=symbol_name(vs_base[0]);
  443. }
  444.  
  445. Lmake_symbol()
  446. {
  447.     check_arg(1);
  448.  
  449.     check_type_string(&vs_base[0]);
  450.     vs_base[0] = make_symbol(vs_base[0]);
  451. }
  452.  
  453. @(defun copy_symbol (sym &optional cp &aux x)
  454. @
  455.     check_type_symbol(&sym);
  456.     x = make_symbol(sym);
  457.     if (cp == Cnil)
  458.         @(return x)
  459.     x->s.s_stype = sym->s.s_stype;
  460.     x->s.s_dbind = sym->s.s_dbind;
  461.     x->s.s_mflag = sym->s.s_mflag;
  462.     x->s.s_gfdef = sym->s.s_gfdef;
  463.     x->s.s_plist = copy_list(sym->s.s_plist);
  464.     @(return x)
  465. @)
  466.  
  467. @(defun gensym (&optional (x gensym_prefix) &aux sym)
  468.     int i, j;
  469. @
  470.     if (type_of(x) == t_string)
  471.         gensym_prefix = x;
  472.     else {
  473.         check_type_non_negative_integer(&x);
  474.         if (type_of(x) == t_fixnum)
  475.             gensym_counter = fix(x);
  476.         else
  477.             gensym_counter = 0;
  478.             /*  incorrect implementation  */
  479.     }
  480.     for (j = gensym_counter, i = 0;  j > 0;  j /= 10)
  481.         i++;
  482.     if (i == 0)
  483.         i++;
  484.     i += gensym_prefix->st.st_fillp;
  485.     set_up_string_register("");
  486.     sym = make_symbol(string_register);
  487.     sym->s.s_fillp = i;
  488.     sym->s.s_self = alloc_relblock(i);
  489.     for (j = 0;  j < gensym_prefix->st.st_fillp;  j++)
  490.         sym->s.s_self[j] = gensym_prefix->st.st_self[j];
  491.     if ((j = gensym_counter) == 0)
  492.         sym->s.s_self[--i] = '0';
  493.     else
  494.         for (;  j > 0;  j /= 10)
  495.             sym->s.s_self[--i] = j%10 + '0';
  496.     gensym_counter++;
  497.     @(return sym)
  498. @)
  499.  
  500. @(defun gentemp (&optional (prefix gentemp_prefix)
  501.                (pack `current_package()`)
  502.          &aux smbl)
  503.     int i, j;
  504. @
  505.     check_type_string(&prefix);
  506.     check_type_package(&pack);
  507. /*
  508.     gentemp_counter = 0;
  509. */
  510. ONCE_MORE:
  511.     for (j = gentemp_counter, i = 0;  j > 0;  j /= 10)
  512.         i++;
  513.     if (i == 0)
  514.         i++;
  515.     i += prefix->st.st_fillp;
  516.     set_up_string_register("");
  517.     string_register->st.st_fillp = string_register->st.st_dim = i;
  518.     string_register->st.st_self = alloc_relblock(i);
  519.     for (j = 0;  j < prefix->st.st_fillp;  j++)
  520.         string_register->st.st_self[j] = prefix->st.st_self[j];
  521.     if ((j = gentemp_counter) == 0)
  522.         string_register->st.st_self[--i] = '0';
  523.     else
  524.         for (;  j > 0;  j /= 10)
  525.             string_register->st.st_self[--i] = j%10 + '0';
  526.     gentemp_counter++;
  527.     smbl = intern(string_register, pack);
  528.     if (intern_flag != 0)
  529.         goto ONCE_MORE;
  530.     @(return smbl)
  531. @)
  532.  
  533. Lsymbol_package()
  534. {
  535.     check_arg(1);
  536.  
  537.     check_type_symbol(&vs_base[0]);
  538.     vs_base[0] = vs_base[0]->s.s_hpack;
  539. }
  540.  
  541. Lkeywordp()
  542. {
  543.     check_arg(1);
  544.  
  545.     if (type_of(vs_base[0]) == t_symbol && keywordp(vs_base[0]))
  546.         vs_base[0] = Ct;
  547.     else
  548.         vs_base[0] = Cnil;
  549. }
  550.  
  551. /*
  552.     (SI:PUT-F plist value indicator)
  553.     returns the new property list with value for property indicator.
  554.     It will be used in SETF for GETF.
  555. */
  556. siLput_f()
  557. {
  558.     check_arg(3);
  559.  
  560.     vs_base[0] = putf(vs_base[0], vs_base[1], vs_base[2]);
  561.     vs_top = vs_base+1;
  562. }
  563.  
  564. /*
  565.     (SI:REM-F plist indicator) returns two values:
  566.  
  567.         * the new property list
  568.           in which property indcator is removed
  569.  
  570.         * T    if really removed
  571.           NIL    otherwise.
  572.  
  573.     It will be used for macro REMF.
  574. */
  575. siLrem_f()
  576. {
  577.     check_arg(2);
  578.  
  579.     if (remf(&vs_base[0], vs_base[1]))
  580.         vs_base[1] = Ct;
  581.     else
  582.         vs_base[1] = Cnil;
  583. }
  584.  
  585. siLset_symbol_plist()
  586. {
  587.     check_arg(2);
  588.  
  589.     check_type_symbol(&vs_base[0]);
  590.     vs_base[0]->s.s_plist = vs_base[1];
  591.     vs_base[0] = vs_base[1];
  592.     vs_pop;
  593. }
  594.  
  595. siLputprop()
  596. {
  597.     check_arg(3);
  598.  
  599.     check_type_symbol(&vs_base[0]);
  600.     vs_base[0]->s.s_plist
  601.     = putf(vs_base[0]->s.s_plist, vs_base[1], vs_base[2]);
  602.     vs_base[0] = vs_base[1];
  603.     vs_top = vs_base+1;
  604. }
  605.  
  606.  
  607. odd_plist(place)
  608. object place;
  609. {
  610.     FEerror("The length of the property-list ~S is odd.", 1, place);
  611. }
  612.  
  613.  
  614. init_symbol()
  615. {
  616.     string_register = alloc_simple_string(0);
  617.     gensym_prefix = make_simple_string("G");
  618.     gensym_counter = 0;
  619.     gentemp_prefix = make_simple_string("T");
  620.     gentemp_counter = 0;
  621.     token = alloc_simple_string(PAGESIZE);
  622.     token->st.st_fillp = 0;
  623.     token->st.st_self = alloc_contblock(PAGESIZE);
  624.     token->st.st_hasfillp = TRUE;
  625.     token->st.st_adjustable = TRUE;
  626.  
  627.     enter_mark_origin(&string_register);
  628.     enter_mark_origin(&gensym_prefix);
  629.     enter_mark_origin(&gentemp_prefix);
  630.     enter_mark_origin(&token);
  631. }
  632.  
  633. init_symbol_function()
  634. {
  635.     make_function("GET", Lget);
  636.     make_function("REMPROP", Lremprop);
  637.     make_function("SYMBOL-PLIST", Lsymbol_plist);
  638.     make_function("GETF", Lgetf);
  639.     make_function("GET-PROPERTIES", Lget_properties);
  640.     make_function("SYMBOL-NAME", Lsymbol_name);
  641.     make_function("MAKE-SYMBOL", Lmake_symbol);
  642.     make_function("COPY-SYMBOL", Lcopy_symbol);
  643.     make_function("GENSYM", Lgensym);
  644.     make_function("GENTEMP", Lgentemp);
  645.     make_function("SYMBOL-PACKAGE", Lsymbol_package);
  646.     make_function("KEYWORDP", Lkeywordp);
  647.  
  648.     make_si_function("PUT-F", siLput_f);
  649.     make_si_function("REM-F", siLrem_f);
  650.     make_si_function("SET-SYMBOL-PLIST", siLset_symbol_plist);
  651.  
  652.     make_si_function("PUTPROP", siLputprop);
  653.     make_si_sfun("SPUTPROP",sputprop,3);
  654.  
  655.  
  656.     siSpname = make_si_ordinary("PNAME");
  657.     enter_mark_origin(&siSpname);
  658. }
  659.